home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / INSPECT.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  11.1 KB  |  372 lines
  1. ; INSPECT.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        The Inspector and %PCS-EDIT-BINDING            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Nov 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. (define %inspect                    ; %INSPECT
  23.   (lambda (cur-env)
  24.     (cond ((environment? cur-env)
  25.        (%inspector '() '() '()
  26.                cur-env
  27.                (%reify-stack (+ (%reify-stack -1) 6))
  28.                0))
  29.       ((closure? cur-env)
  30.        (%inspect (procedure-environment cur-env)))
  31.       (else
  32.        (display "Invalid operand to INSPECT: ")
  33.        (display cur-env)))))
  34.  
  35.  
  36. (define %inspector                    ; %inspector
  37.   (letrec
  38.    ((table
  39.      '((1 . "All")                    ; ctrl-A
  40.        (2 . "Backtrace calls")                ; ctrl-B
  41.        (3 . "Current environment frame")        ; ctrl-C
  42.        (4 . "Down to callee")                ; ctrl-D
  43.        (5 . "Edit: ")                    ; ctrl-E
  44.        (7 . "Go")                    ; ctrl-G
  45.        (9 . "Inspect: ")                ; ctrl-I
  46.        (12 . "List Procedure")                ; ctrl-L
  47.        (13 . "Repeat Breakpoint Message")        ; ctrl-M
  48.        (16 . "`Parent' environment frame")        ; ctrl-P
  49.        (17 . "Quit")                    ; ctrl-Q
  50.        (18 . "Return with the value: ")            ; ctrl-R
  51.        (19 . "`Son' environment frame")            ; ctrl-S
  52.        (21 . "Up to caller")                ; ctrl-U
  53.        (22 . "Value of: ")                ; ctrl-V
  54.        (23 . "Where am I?")                ; ctrl-W
  55.        (#\SPACE . "Value of: ")
  56.        (#\! . "Reinitialize INSPECT!")
  57.        (#\? . "?")))
  58.  
  59.     (repl
  60.      (lambda ()
  61.        (pcs-clear-registers)
  62.        (fresh-line)
  63.        (newline)
  64.        (display "[Inspect] ")
  65.        (flush-input)
  66.        (let* ((ch (read-char))
  67.           (key (if (memv ch '(#\SPACE #\! #\?))
  68.                ch
  69.                (char->integer ch)))
  70.           (entry (assv key table)))
  71.      (when entry
  72.            (display (cdr entry)))
  73.      (case key
  74.        (1   (all cur-env 0)(repl))            ; ctrl-A
  75.        (2   (newline)(where stk-index)        ; ctrl-B
  76.         (backtrace stk-index)(repl))
  77.        (3   (newline)                ; ctrl-C
  78.         (current cur-env 0 #T)
  79.         (repl))
  80.        (4   (newline)                ; ctrl-D
  81.         (down)(repl))
  82.        (5   (let ((ans                ; ctrl-E
  83.                (%pcs-edit-binding '() (read) cur-env)))
  84.           (when (string? ans)(display ans))
  85.           (repl)))
  86.        ((7 18)                    ; ctrl-G, ctrl-R
  87.             (leave key))
  88.        (12  (newline)                ; ctrl-L
  89.         (pp (%reify-stack (+ stk-index 15)))
  90.         (repl))
  91.        (13  (newline)                ; ctrl-M
  92.         (display kind)
  93.         (when kind
  94.               (when msg (display msg))
  95.               (newline)
  96.               (write irritant))
  97.         (repl))
  98.        (16  (newline)                ; ctrl-P
  99.         (parent cur-env)(repl))
  100.        (17  (reset))                ; ctrl-Q
  101.        (19  (newline)                ; ctrl-S
  102.         (son)(repl))
  103.        (21  (newline)                ; ctrl-U
  104.         (up)(repl))
  105.        ((22 #\SPACE)
  106.             (pp (eval (read) cur-env))        ; ctrl-V, SPACE
  107.         (repl))
  108.        (23  (newline)                ; ctrl-W
  109.         (where stk-index)(repl))
  110.        (#\!   (newline)(init)(repl))        ;  !
  111.        (#\?   (newline)                ;  ?
  112.           (help)(repl))
  113.        (else
  114.         (if (eqv? key 9)                ; ctrl-I
  115.         (let ((env (eval (read) cur-env)))
  116.           (cond ((or (environment? env)
  117.                  (closure? env)
  118.                  (delayed-object? env))
  119.              (set! (fluid %inspector-continuation) '())
  120.              (%inspect env))
  121.             (else
  122.              (display (integer->char 7))    ; beep
  123.              (display "  ?  Not an environment: ")
  124.              (write env)))
  125.           (repl))
  126.         (begin
  127.           (display (integer->char 7))        ; beep
  128.           (display "  ?  Invalid response...  Type `?' for help")
  129.           (repl))))))
  130.        ))
  131.  
  132.     (All
  133.      (lambda (env depth)
  134.        (fresh-line)
  135.        (when (and env (not (eq? env user-global-environment)))
  136.          (current env depth #T)
  137.          (all (environment-parent env) (+ depth 1)))))
  138.  
  139.     (Backtrace
  140.      (lambda (stk-index)
  141.        (let ((si (%reify-stack (+ stk-index 6))))
  142.      (fresh-line)
  143.      (when (positive? si)
  144.            (display "  called from   ")
  145.            (display (%reify-stack (+ si 15)))
  146.            (backtrace si)))))
  147.  
  148.     (Current
  149.      (lambda (env depth verbose?)
  150.        (when verbose?
  151.          (display "Environment frame bindings at level ")
  152.          (display (+ depth (length son-stk)))
  153.          (cond ((eq? env user-initial-environment)
  154.             (display "  (USER-INITIAL-ENVIRONMENT)"))
  155.            ((eq? env user-global-environment)
  156.             (display "  (USER-GLOBAL-ENVIRONMENT)"))))
  157.        (when (or verbose?
  158.          (= (%reify env -1) 12))    ; not a global environment
  159.          (let ((frame (environment-bindings env)))
  160.            (if (null? frame)
  161.            (begin
  162.              (newline)
  163.              (display "    --no variables--"))
  164.            (let loop ((pairs frame))
  165.              (when pairs
  166.                (newline)
  167.                (display "    ")
  168.                (if (char-ready?)
  169.                    (display "[aborted]")
  170.                    (let ((val (cdar pairs)))
  171.                  (display (caar pairs))     ; var
  172.                  (display " ")
  173.                  (tab27 (current-column))
  174.                  (cond ((pair? val)
  175.                     (display "-- list --"))
  176.                        ((vector? val)
  177.                     (display "-- vector --"))
  178.                        (else (write val)))
  179.                  (loop (cdr pairs))))))
  180.            )))))
  181.  
  182.     (Down
  183.      (lambda ()
  184.        (if (null? down-stk)
  185.        (display "  ?  Can't move Down")
  186.        (let ((si (car down-stk)))
  187.          (set! down-stk (cdr down-stk))
  188.          (set! stk-index si)
  189.          (set! son-stk '())
  190.          (set! cur-env (%reify-stack (+ si 9)))
  191.          (where si)))))
  192.  
  193.     (Leave
  194.      (lambda (key)
  195.        (cond ((not (zero? exit-code))
  196.           (newline)
  197.           (display "  ?  Sorry, the program is not resumable")
  198.           (repl))
  199.          ((eqv? key 7)                ; ctrl-G
  200.           (newline)
  201.           '())
  202.          ((memq msg '(BREAK-ENTRY BREAK-EXIT))
  203.           ((fluid %*BREAK*continuation) (eval (read) cur-env)))
  204.          (else
  205.           (newline)
  206.           (display "  ?  Sorry, use `ctrl-R' only to return from BREAK")
  207.           (repl)))))
  208.  
  209.     (Parent
  210.      (lambda (env)
  211.        (let ((penv (environment-parent env)))
  212.      (if (null? penv)
  213.          (display "  ?  No parent exists")
  214.          (begin
  215.            (set! son-stk (cons env son-stk))
  216.            (set! cur-env penv)
  217.            (current penv 0 #T))))))
  218.  
  219.     (Son
  220.      (lambda ()
  221.        (if (null? son-stk)
  222.        (display "  ?  No son exists")
  223.        (begin
  224.          (set! cur-env (car son-stk))
  225.          (set! son-stk (cdr son-stk))
  226.          (current cur-env 0 #T)))))
  227.  
  228.     (Up
  229.      (lambda ()
  230.        (let ((si (%reify-stack (+ stk-index 6))))
  231.      (if (positive? si)
  232.          (begin
  233.            (set! down-stk (cons stk-index down-stk))
  234.            (set! son-stk '())
  235.            (set! cur-env (%reify-stack (+ si 9)))
  236.            (set! stk-index si)
  237.            (where si))
  238.          (display "  ?  Can't move Up")))))
  239.  
  240.     (Where
  241.      (lambda (si)
  242.        (display "Stack frame for ")
  243.        (display (%reify-stack (+ si 15)))
  244.        (current cur-env 0 #F) ))
  245.  
  246.     (tab27
  247.      (lambda (cur)
  248.        (cond ((> 24 cur) (display "   ")(tab27 (+ cur 3)))
  249.          ((> 27 cur) (display " ")  (tab27 (+ cur 1)))
  250.          ((= 27 cur)  cur)
  251.          (else        (newline)    (tab27 1)))))
  252.  
  253.     (init
  254.      (lambda ()
  255.        (set! son-stk '())
  256.        (set! down-stk '())
  257.        (set! cur-env orig-env)
  258.        (set! stk-index orig-stk-index) ))
  259.  
  260.     (help
  261.      (lambda ()
  262.        (mapc (lambda (x)(display x))
  263.      '("   ?    -- display this command summary" #\newline
  264.        "   !    -- reinitialize INSPECT" #\newline
  265.        " ctrl-A -- display All environment frame bindings" #\newline
  266.        " ctrl-B -- display procedure call Backtrace" #\newline
  267.        " ctrl-C -- display Current environment frame bindings" #\newline
  268.        " ctrl-D -- move Down to callee's stack frame" #\newline
  269.        " ctrl-E -- Edit variable binding" #\newline
  270.        " ctrl-G -- Go  (resume execution)" #\newline
  271.        " ctrl-I -- evaluate one expression and Inspect the result"
  272.        #\newline
  273.        " ctrl-L -- List current procedure" #\newline
  274.        " ctrl-M -- repeat the breakpoint Message" #\newline
  275.        " ctrl-P -- move to Parent environment's frame" #\newline
  276.        " ctrl-Q -- Quit  (RESET to top level)" #\newline
  277.        " ctrl-R -- Return from BREAK with a value" #\newline
  278.        " ctrl-S -- move to Son environment's frame" #\newline
  279.        " ctrl-U -- move Up to caller's stack frame" #\newline
  280.        " ctrl-V -- eValuate one expression in current environment"
  281.        #\newline
  282.        " ctrl-W -- (Where) Display current stack frame" #\newline
  283.        "To enter `ctrl-A', press both `CTRL' and `A'."
  284.            ))))
  285.  
  286.     ;; data
  287.  
  288.     (down-stk '())
  289.     (son-stk '())
  290.     (orig-env '())
  291.     (orig-stk-index '())
  292.     (msg '())
  293.     (kind '())
  294.     (irritant '())
  295.     (cur-env '())
  296.     (stk-index '())
  297.     (exit-code '())
  298.     )
  299.    (lambda (msg0 kind0 irritant0 cur-env0 stk-index0 exit-code0)
  300.      (if (and (fluid-bound? %inspector-continuation)
  301.           (not (null? (fluid %inspector-continuation))))
  302.      ((fluid %inspector-continuation) '())
  303.      (fluid-let ((%inspector-continuation '()))
  304.        (set! msg msg0)
  305.        (set! kind kind0)
  306.        (set! irritant irritant0)
  307.        (set! cur-env cur-env0)
  308.        (set! stk-index stk-index0)
  309.        (set! exit-code exit-code0)
  310.        (set! orig-env cur-env0)
  311.        (set! orig-stk-index stk-index0)
  312.        (init)
  313.        (call/cc
  314.           (lambda (k)
  315.         (set! (fluid %inspector-continuation) k)))
  316.        (repl)))
  317.      )))
  318.  
  319.  
  320.  
  321. ;;; %PCS-EDIT-BINDING
  322. ;;;
  323. ;;;   argument OBJ:       () or value to be edited
  324. ;;;   optional arg NAME:  symbol
  325. ;;;   optional arg ENV:   environment for name
  326. ;;;
  327. ;;;   When NAME and ENV are not supplied, %PCS-EDIT-BINDING calls the
  328. ;;;   editor to edit OBJ.
  329. ;;;
  330. ;;;   When NAME and ENV are supplied, %PCS-EDIT-BINDING calls the editor
  331. ;;;   to create a new binding for the name in the environment.  If OBJ is
  332. ;;;   nil, the current binding of NAME in ENV is edited instead of OBJ.
  333. ;;;
  334. ;;;   returns either (1) an error message string or
  335. ;;;             (2) (LIST edited-value)
  336.  
  337. (define %pcs-edit-binding
  338.   (letrec ((help
  339.         (lambda (obj name)
  340.           (if (closure? obj)
  341.           (let ((info (assq 'SOURCE (%reify obj 0))))
  342.             (if (null? info)
  343.             "[No source found for compiled procedure.]"
  344.             (let ((new (edit (cdr info))))
  345.               (if (and (pair? new)
  346.                    (eq? (car new) 'LAMBDA))
  347.                   (let ((mode pcs-debug-mode))
  348.                 (set! pcs-debug-mode #T)
  349.                 (let ((value (eval new)))
  350.                   (set! pcs-debug-mode mode)
  351.                   (%reify! value 0
  352.                       (cons (cons 'SOURCE new) name))
  353.                   (list value)))
  354.                   (list new)))))
  355.           (list (edit obj))))))
  356.      (lambda (obj . rebind)
  357.        (if (null? rebind)
  358.        (help obj rebind)
  359.        (let ((name (car rebind))
  360.          (env  (cadr rebind)))
  361.          (if (and (symbol? name)(environment? env))
  362.          (let ((value-list (help (or obj (cdr (%env-lu name env)))
  363.                     name)))
  364.            (if (atom? value-list)
  365.                value
  366.                (let ((value (car value-list))
  367.                  (cell (%env-lu name env)))
  368.              (if (null? cell)
  369.                  (%define name value env)
  370.                  (set-cdr! cell value)))))
  371.          "[Invalid argument]"))))))
  372.